home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / perl5 / Mail / Util.pm < prev    next >
Text File  |  2008-04-14  |  3KB  |  149 lines
  1. # Copyrights 1995-2008 by Mark Overmeer <perl@overmeer.net>.
  2. #  For other contributors see ChangeLog.
  3. # See the manual pages for details on the licensing terms.
  4. # Pod stripped from pm file by OODoc 1.04.
  5. use strict;
  6.  
  7. package Mail::Util;
  8. use vars '$VERSION';
  9. $VERSION = '2.03';
  10. use base 'Exporter';
  11.  
  12. our @EXPORT_OK = qw(read_mbox maildomain mailaddress);
  13.  
  14. use Carp;
  15. sub Version { our $VERSION }
  16.  
  17. my ($domain, $mailaddress);
  18. my @sendmailcf = qw(/etc /etc/sendmail /etc/ucblib
  19.     /etc/mail /usr/lib /var/adm/sendmail);
  20.  
  21.  
  22. sub read_mbox($)
  23. {   my $file  = shift;
  24.  
  25.     local *FH;
  26.     open FH,'<', $file
  27.     or croak "cannot open '$file': $!\n";
  28.  
  29.     local $_;
  30.     my @mbox;
  31.     my $mail  = [];
  32.     my $blank = 1;
  33.  
  34.     while(<FH>)
  35.     {   if($blank && /^From .*\d{4}/)
  36.         {   push @mbox, $mail if @$mail;
  37.         $mail  = [ $_ ];
  38.         $blank = 0;
  39.     }
  40.     else
  41.         {   $blank = m/^$/ ? 1 : 0;
  42.         push @$mail, $_;
  43.     }
  44.     }
  45.  
  46.     push @mbox, $mail if @$mail;
  47.     close FH;
  48.  
  49.     wantarray ? @mbox : \@mbox;
  50. }
  51.  
  52.  
  53. sub maildomain()
  54. {   return $domain
  55.     if defined $domain;
  56.  
  57.     $domain = $ENV{MAILDOMAIN}
  58.         and return $domain;
  59.  
  60.     # Try sendmail configuration file
  61.  
  62.     my $config = (grep -r, map {"$_/sendmail.cf"} @sendmailcf)[0];
  63.  
  64.     local *CF;
  65.     local $_;
  66.     if(defined $config && open CF, '<', $config)
  67.     {   my %var;
  68.     while(<CF>)
  69.         {   if(my ($v, $arg) = /^D([a-zA-Z])([\w.\$\-]+)/)
  70.             {   $arg =~ s/\$([a-zA-Z])/exists $var{$1} ? $var{$1} : '$'.$1/eg;
  71.         $var{$v} = $arg;
  72.         }
  73.     }
  74.     close CF;
  75.     $domain = $var{j} if defined $var{j};
  76.     $domain = $var{M} if defined $var{M};
  77.  
  78.         $domain = $1
  79.             if $domain && $domain =~ m/([A-Za-z0-9](?:[\.\-A-Za-z0-9]+))/;
  80.  
  81.     return $domain
  82.         if defined $domain && $domain !~ /\$/;
  83.     }
  84.  
  85.     # Try smail config file if exists
  86.  
  87.     if(open CF, '<', "/usr/lib/smail/config")
  88.     {   while(<CF>)
  89.         {   if( /\A\s*hostnames?\s*=\s*(\S+)/ )
  90.             {   $domain = (split /\:/,$1)[0];
  91.         last;
  92.         }
  93.     }
  94.     close CF;
  95.  
  96.     return $domain
  97.         if defined $domain;
  98.     }
  99.  
  100.     # Try a SMTP connection to 'mailhost'
  101.  
  102.     if(eval {require Net::SMTP})
  103.     {   foreach my $host (qw(mailhost localhost))
  104.         {   # hosts are local, so short timeout
  105.             my $smtp = eval { Net::SMTP->new($host, Timeout => 5) };
  106.         if(defined $smtp)
  107.             {   $domain = $smtp->domain;
  108.         $smtp->quit;
  109.         last;
  110.         }
  111.     }
  112.     }
  113.  
  114.     # Use internet(DNS) domain name, if it can be found
  115.     $domain = Net::Domain::domainname()
  116.         if !defined $domain && eval {require Net::Domain};
  117.  
  118.     $domain ||= "localhost";
  119. }
  120.  
  121.  
  122. sub mailaddress()
  123. {  return $mailaddress
  124.        if defined $mailaddress;
  125.  
  126.     # Get user name from environment
  127.     $mailaddress = $ENV{MAILADDRESS};
  128.  
  129.     unless($mailaddress || $^O ne 'MacOS')
  130.     {   require Mac::InternetConfig;
  131.  
  132.         no strict;
  133.     Mac::InternetConfig->import;
  134.     $mailaddress = $InternetConfig{kICEmail()};
  135.     }
  136.  
  137.     $mailaddress ||= $ENV{USER} || $ENV{LOGNAME} || eval {getpwuid $>}
  138.                  ||  "postmaster";
  139.  
  140.     # Add domain if it does not exist
  141.     $mailaddress .= '@' . maildomain
  142.     if $mailaddress !~ /\@/;
  143.  
  144.     $mailaddress =~ s/(^.*<|>.*$)//g;
  145.     $mailaddress;
  146. }
  147.  
  148. 1;
  149.